home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch6 / MakeGray.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-04-25  |  6.2 KB  |  193 lines
  1. VERSION 5.00
  2. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
  3. Begin VB.Form frmMakeGray 
  4.    Caption         =   "MakeGray []"
  5.    ClientHeight    =   2985
  6.    ClientLeft      =   165
  7.    ClientTop       =   735
  8.    ClientWidth     =   5145
  9.    LinkTopic       =   "Form2"
  10.    ScaleHeight     =   2985
  11.    ScaleWidth      =   5145
  12.    StartUpPosition =   3  'Windows Default
  13.    Begin MSComDlg.CommonDialog dlgOpenFile 
  14.       Left            =   2760
  15.       Top             =   0
  16.       _ExtentX        =   847
  17.       _ExtentY        =   847
  18.       _Version        =   393216
  19.    End
  20.    Begin VB.PictureBox picOriginal 
  21.       AutoSize        =   -1  'True
  22.       Height          =   2775
  23.       Left            =   120
  24.       ScaleHeight     =   181
  25.       ScaleMode       =   3  'Pixel
  26.       ScaleWidth      =   157
  27.       TabIndex        =   1
  28.       Top             =   120
  29.       Width           =   2415
  30.    End
  31.    Begin VB.PictureBox picResult 
  32.       Height          =   2775
  33.       Left            =   2640
  34.       ScaleHeight     =   181
  35.       ScaleMode       =   3  'Pixel
  36.       ScaleWidth      =   157
  37.       TabIndex        =   0
  38.       Top             =   120
  39.       Width           =   2415
  40.    End
  41.    Begin VB.Menu mnuFile 
  42.       Caption         =   "&File"
  43.       Begin VB.Menu mnuFileOpen 
  44.          Caption         =   "&Open..."
  45.          Shortcut        =   ^O
  46.       End
  47.       Begin VB.Menu mnuFileSaveAs 
  48.          Caption         =   "Save &As..."
  49.          Shortcut        =   ^A
  50.       End
  51.    End
  52. Attribute VB_Name = "frmMakeGray"
  53. Attribute VB_GlobalNameSpace = False
  54. Attribute VB_Creatable = False
  55. Attribute VB_PredeclaredId = True
  56. Attribute VB_Exposed = False
  57. Option Explicit
  58. ' Arrange the controls.
  59. Private Sub ArrangeControls()
  60.     ' Position the result PictureBox.
  61.     picResult.Move _
  62.         picOriginal.Left + picOriginal.Width + 120, _
  63.         picOriginal.Top, _
  64.         picOriginal.Width, _
  65.         picOriginal.Height
  66.     picResult.Cls
  67.     ' This makes the image resize itself to
  68.     ' fit the picture.
  69.     picResult.Picture = picResult.Image
  70.     ' Make the form big enough.
  71.     Width = picResult.Left + picResult.Width + _
  72.         Width - ScaleWidth + 120
  73.     Height = picResult.Top + picResult.Height + _
  74.         Height - ScaleHeight + 120
  75.     DoEvents
  76. End Sub
  77. ' Transform the image.
  78. Private Sub TransformImage()
  79. Dim pixels() As RGBTriplet
  80. Dim bits_per_pixel As Integer
  81. Dim X As Integer
  82. Dim Y As Integer
  83. Dim shade As Integer
  84.     ' Get the pixels from picOriginal.
  85.     GetBitmapPixels picOriginal, pixels, bits_per_pixel
  86.     ' Set the pixel colors.
  87.     For Y = 0 To picOriginal.ScaleHeight - 1
  88.         For X = 0 To picOriginal.ScaleWidth - 1
  89.             With pixels(X, Y)
  90.                 shade = (CInt(.rgbRed) + .rgbGreen + _
  91.                     .rgbBlue) / 3
  92.                 .rgbRed = shade
  93.                 .rgbGreen = shade
  94.                 .rgbBlue = shade
  95.             End With
  96.         Next X
  97.     Next Y
  98.     ' Set picResult's pixels.
  99.     SetBitmapPixels picResult, bits_per_pixel, pixels
  100.     picResult.Picture = picResult.Image
  101. End Sub
  102. ' Start in the current directory.
  103. Private Sub Form_Load()
  104.     picOriginal.AutoSize = True
  105.     picOriginal.ScaleMode = vbPixels
  106.     picOriginal.AutoRedraw = True
  107.     picResult.ScaleMode = vbPixels
  108.     picResult.AutoRedraw = True
  109.     dlgOpenFile.CancelError = True
  110.     dlgOpenFile.InitDir = App.Path
  111.     dlgOpenFile.Filter = _
  112.         "Bitmaps (*.bmp)|*.bmp|" & _
  113.         "GIFs (*.gif)|*.gif|" & _
  114.         "JPEGs (*.jpg)|*.jpg;*.jpeg|" & _
  115.         "Icons (*.ico)|*.ico|" & _
  116.         "Cursors (*.cur)|*.cur|" & _
  117.         "Run-Length Encoded (*.rle)|*.rle|" & _
  118.         "Metafiles (*.wmf)|*.wmf|" & _
  119.         "Enhanced Metafiles (*.emf)|*.emf|" & _
  120.         "Graphic Files|*.bmp;*.gif;*.jpg;*.jpeg;*.ico;*.cur;*.rle;*.wmf;*.emf|" & _
  121.         "All Files (*.*)|*.*"
  122. End Sub
  123. ' Load the indicated file.
  124. Private Sub mnuFileOpen_Click()
  125. Dim file_name As String
  126.     ' Let the user select a file.
  127.     On Error Resume Next
  128.     dlgOpenFile.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
  129.     dlgOpenFile.ShowOpen
  130.     If Err.Number = cdlCancel Then
  131.         Exit Sub
  132.     ElseIf Err.Number <> 0 Then
  133.         Beep
  134.         MsgBox "Error selecting file.", , vbExclamation
  135.         Exit Sub
  136.     End If
  137.     On Error GoTo 0
  138.     Screen.MousePointer = vbHourglass
  139.     DoEvents
  140.     file_name = Trim$(dlgOpenFile.FileName)
  141.     dlgOpenFile.InitDir = Left$(file_name, Len(file_name) _
  142.         - Len(dlgOpenFile.FileTitle) - 1)
  143.     Caption = "MakeGray [" & dlgOpenFile.FileTitle & "]"
  144.     ' Open the original file.
  145.     On Error GoTo LoadError
  146.     picOriginal.Picture = LoadPicture(file_name)
  147.     On Error GoTo 0
  148.     ' Make picResult the same size and position it.
  149.     ArrangeControls
  150.     ' Transform the image.
  151.     TransformImage
  152.     Screen.MousePointer = vbDefault
  153.     Exit Sub
  154. LoadError:
  155.     Screen.MousePointer = vbDefault
  156.     MsgBox "Error " & Format$(Err.Number) & _
  157.         " opening file '" & file_name & "'" & vbCrLf & _
  158.         Err.Description
  159. End Sub
  160. ' Save the transformed image.
  161. Private Sub mnuFileSaveAs_Click()
  162. Dim file_name As String
  163.     ' Let the user select a file.
  164.     On Error Resume Next
  165.     dlgOpenFile.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
  166.     dlgOpenFile.ShowSave
  167.     If Err.Number = cdlCancel Then
  168.         Exit Sub
  169.     ElseIf Err.Number <> 0 Then
  170.         Beep
  171.         MsgBox "Error selecting file.", , vbExclamation
  172.         Exit Sub
  173.     End If
  174.     On Error GoTo 0
  175.     Screen.MousePointer = vbHourglass
  176.     DoEvents
  177.     file_name = Trim$(dlgOpenFile.FileName)
  178.     dlgOpenFile.InitDir = Left$(file_name, Len(file_name) _
  179.         - Len(dlgOpenFile.FileTitle) - 1)
  180.     Caption = "MakeGray [" & dlgOpenFile.FileTitle & "]"
  181.     ' Save the transformed image into the file.
  182.     On Error GoTo SaveError
  183.     SavePicture picResult.Picture, file_name
  184.     On Error GoTo 0
  185.     Screen.MousePointer = vbDefault
  186.     Exit Sub
  187. SaveError:
  188.     Screen.MousePointer = vbDefault
  189.     MsgBox "Error " & Format$(Err.Number) & _
  190.         " saving file '" & file_name & "'" & vbCrLf & _
  191.         Err.Description
  192. End Sub
  193.